;; =============================================================================
;; introduces function declaration parser
;;

(in-package :oali.core)


;; =============================================================================
;; func instance
(defclass p-func-instance ()
  (
   ;; function's arguments - array (make-array 1 :fill-pointer 0), uninitialized on
   (args :initform nil :accessor args)

   (result :initform nil :accessor result)

   (body :initform nil :accessor body)
   ))

;; =============================================================================
;; parse function call
(defun parse-funcall (context func-id args)
  (let ((func (gethash func-id (funcs context))))
    ;; check function
    (unless func
      (error 'not-defined :entity func-id))

    ;; check args: match size
    (unless (= (length args) (length (args func)))
      (error 'invalid-arguments-count :actual (length args) :expected (length (args func))))
    
    (dolist (arg args)
      ;; TODO: parse args
      (parse-inl-expr context arg))))

;; =============================================================================
;; generics that parses inline expressions
(defun parse-inl-expr (context expr)
  
  (if (consp expr)
      ;; another funcall
      (parse-funcall context (car expr) (cdr expr))
      
      ;; atomic expression case
      (cond
	;; variable (dummy check that it was defined)
	((symbolp expr) (f-var-inst context expr))

	;; string, character or number - leave as it is
	((or (stringp expr) (characterp expr) (numberp expr)) expr)

	;; expression of unexpected type
	(t (error 'unknown-expression :expression expr)))))

;; =============================================================================
;; generics that parses block declarations
(defgeneric parse-block-decl (context id args))

;; function call?
(defmethod parse-block-decl (context func-id args)
  (parse-funcall context func-id args))

;; progn decl
(defmethod parse-block-decl (context (id (eql 'progn)) args)
  (dolist (block-expr args)
    (parse-block-decl context (car block-expr) (cdr block-expr))))

;; helper for let declaration parser
(defun parse-let-var-list (context var-list)
  (declare (ignore context var-list))
  (error 'not-implemented :entity 'let-declaration))

;; let decl
(defmethod parse-block-decl (context (id (eql 'let)) args)
  (destructuring-bind (var-list &rest block-exprs) args

    ;; variable list
    (parse-let-var-list context var-list)

    ;; let block
    (dolist (expr block-exprs)
      (parse-block-decl context (car expr) (cdr expr)))))

;; while decl
(defmethod parse-block-decl (context (id (eql 'while)) args)
  (declare (ignore context args))
  (error 'not-implemented :entity 'while-declaration))

;; return decl
(defmethod parse-block-decl (context (id (eql 'return)) args)
  (declare (ignore context))
  (format t "in return ~a~%" args))


;; =============================================================================
;; parses argument list

(defclass var-decl ()
  (
   ;; mutable
   (mutable :reader mutable :initform nil :initarg :mutable)
   ))

(defun f-add-var-decl (context var-id &optional mutable)
  (check-type var-id symbol)
  
  (let ((vars (vars context)))
    (if (gethash var-id vars)
	(error 'multiple-definition :entity var-id))
    
    (setf (gethash var-id vars) (make-instance 'var-decl :mutable mutable))))

(defun f-var-inst (context var-id)
  (let ((var-inst (gethash var-id (vars context))))
    (unless var-inst
      (error 'not-defined :entity var-id))))


;; helper function
(defun check-args-matches (args func)
  "matches arglist provided in args to the one defined in func"
  
  (let ((func-args (args func))
	(len (length args)))

    ;; match lengths
    (unless (= len (length func-args))
      (error 'invalid-arguments-count
	     :entity args
	     :actual len
	     :expected (length func-args)
	     :where 'function-declaration))

    ;; match each args
    (loop for i from 0 to (1- len) do
	 (unless (eq (aref args i) (aref func-args i))
	   (error 'illegal-argument
		  :entity (aref args i)
		  :expected (aref func-args i)
		  :pos (1- len))))))


(defun parse-func-decl-arg-list (context arglist)
  "parses arglist given and matches with the one containing in the current function, or creates new one"

  (let ((func (current-func context)))

    ;; parse arglist.
    ;; args-collect-mode implies that the function was not declared before,
    ;; e.g. there is no any forward declaration
    (let ((args-collect-mode (null (args func)))
	  ;; arguments vector - 1-dim array with fill-pointer at the very first element
	  (args (make-array 1 :fill-pointer 0 :adjustable t)))

      ;; function declared first time - arguments shall be collected
      (if args-collect-mode
	  (setf (args func) args))

      ;; add corresponding accessible var declaration and append argument to the args vector
      (dolist (arg-id arglist)

	;; TODO: accept typed argument declarations
	(unless (symbolp arg-id)
	  (error 'not-implemented :entity 'typed-argument-declaration))
	
	(f-add-var-decl context arg-id)
	(vector-push-extend arg-id args))

      ;; match arg lists if needed
      ;; TODO: match types, for now it is sufficient to require exact matching of argument names
      (unless args-collect-mode (check-args-matches args func)))))

;; =============================================================================
;; parses function block specifiers (function implementation or constraints)
(defun parse-func-spec (context spec-id args)
  (case spec-id
    (:returns (error 'not-implemented :entity 'returns-declaration))
    (t (progn
	 ;; parse block decl
	 (if (body (current-func context))
	     (error 'multiple-definition :entity 'function-body-declaration))

	 ;; TODO: more complex body definition?
	 (setf (body (current-func context)) (append (list spec-id) args))
	 
	 (parse-block-decl context spec-id args)))))


;; =============================================================================
;; parses func decl
(defun parse-func-decl (context func-name-id args)
  (let ((arglist (car args))
	(specs (cdr args))
	(funcs (funcs context))
	func)

    ;; vars/current-func shall not be declared
    (unless (and (null (vars context)) (null (current-func context)))
      (error 'internal-error :entity "vars or current-func slot(s) in the context instance"))

    ;; define new var environment
    (setf (vars context) (make-hash-table))

    ;; get function instance
    (setf func (gethash func-name-id funcs))

    ;; for new functions - create new instance of the function instance class
    (if (null func) (setf (gethash func-name-id funcs)
			  (setf func (make-instance 'p-func-instance))))

    ;; define current function
    (setf (current-func context) func)

    ;; parse arg list
    (parse-func-decl-arg-list context arglist)

    ;; parse specifications - `returns', `body' - and watch that they matches prev declaration
    (dolist (func-spec specs)
      (parse-func-spec context (car func-spec) (cdr func-spec))))

  ;; clean up context - reset vars and current func
  (setf (vars context) nil)
  (setf (current-func context) nil))
